;;########################################################################
;; regmob.lsp
;; OLS, Robust & Monotonic Regression ViSta model object
;; Contains code for morals-model-object-proto
;; Copyright (c) 1995-19966 by Carla M. Bann
;; Copyright (c) 1997-2000 by Carla M. Bann and Forrest W. Young
;;########################################################################
;(load (strcat *vista-dir-name* "regress.lsp"))

(defun regression-analysis 
  (&key 
   (data current-data)  
   (title "Regression Analysis")
   (name nil)
   (dialog nil)
   (iterations 20);20
   (method "OLS") ;robust monotonic ols
   (max-rsq 1)
   (min-rsq-improve .00000001)
   (response nil)
   (predictors nil)
   )
  (if (or (not response) (not predictors)) (setf dialog t))
  (if (not (eq current-object data)) (setcd data))
  (if (not name) 
      (setf name (strcat "REG-" (send current-data :name))))
  (if (not (listp response)) (setf response (list response)))
  (send morals-model-object-proto 
        :new response predictors method iterations max-rsq min-rsq-improve
        "Regres" data title name dialog))

(defun regression-visualization
  (&key 
   (data current-data)  
   (title "Multiple Regression Visualization Analysis")
   (name nil)
   (dialog nil)
   (iterations 20);20
   (method "OLS") ;robust monotonic ols
   (max-rsq 1)
   (min-rsq-improve .00000001)
   (response nil)
   (predictors nil)
   )
  (regression-analysis :data data :title title :name name :dialog dialog :iterations iterations :method method :max-rsq max-rsq :min-rsq-improve min-rsq-improve :response response :predictors predictors)
  (visualize-model))

(defun morals (&key (data current-data) 
                    (title "MORALS") 
                    (dialog t)
                    (name nil))
  (if (not (eq (current-object data)) (setcd data)))
  (if (not name) (strcat "REG-" (send current-data :name)))
  (send morals-model-object-proto :new 1 data title name dialog))

  
(defun morals 
  (&key 
   (data current-data)  
   (title "Morals")
   (name nil)
   (dialog t)
   (iter 20)
   (max-rsq 1)
   (min-rsq-improve .00000001)
   )
  (if (not (eq current-object data)) (setcd data))
  (if (not name) 
      (setf name (strcat "REG-" (send current-data :name))))
  (send morals-model-object-proto 
          :new iter max-rsq min-rsq-improve 7 data title name dialog))

(defproto morals-model-object-proto 
  '(morals-model data-object iv dv weights intercept iter max-RSq min-RSq-improve varlist spreadplot-supervisor method vif-list lin-reg-model robust-model predictors response simple-reg prev-vis container dialog-nonols control-panel-method) ()
  mv-model-object-proto)

(defmeth morals-model-object-proto :morals-model
  (&optional (object-id nil set))
  (if set (setf (slot-value 'morals-model) object-id))
  (slot-value 'morals-model))

(defmeth morals-model-object-proto :robust-model
  (&optional (object-id nil set))
  (if set (setf (slot-value 'robust-model) object-id))
  (slot-value 'robust-model))

(defmeth morals-model-object-proto :lin-reg-model
  (&optional (object-id nil set))
  (if set (setf (slot-value 'lin-reg-model) object-id))
  (slot-value 'lin-reg-model))

(defmeth morals-model-object-proto :data-object
  (&optional (object-id nil set))
  (if set (setf (slot-value 'data-object) object-id))
  (slot-value 'data-object)) 

(defmeth morals-model-object-proto :iv
  (&optional (iv nil set))
  (if set (setf (slot-value 'iv) iv))
  (slot-value 'iv))

(defmeth morals-model-object-proto :dv
  (&optional (dv nil set))
  (if set (setf (slot-value 'dv) dv))
  (slot-value 'dv))

(defmeth morals-model-object-proto :weights
  (&optional (weights nil set))
  (if set (setf (slot-value 'weights) weights))
  (slot-value 'weights))

(defmeth morals-model-object-proto :intercept
  (&optional (intercept nil set))
  (if set (setf (slot-value 'intercept) intercept))
  (slot-value 'intercept))

(defmeth morals-model-object-proto :dialog-nonols
  (&optional (nilt nil set))
  (if set (setf (slot-value 'dialog-nonols) nilt))
  (slot-value 'dialog-nonols))

(defmeth morals-model-object-proto :simple-reg
  (&optional (simple-reg nil set))
  (if set (setf (slot-value 'simple-reg) simple-reg))
  (slot-value 'simple-reg))
 
(defmeth morals-model-object-proto :iter
  (&optional (iter nil set))
  (if set (setf (slot-value 'iter) iter))
  (slot-value 'iter))

(defmeth morals-model-object-proto :max-RSq
  (&optional (max-RSq nil set))
  (if set (setf (slot-value 'max-RSq) max-RSq))
  (slot-value 'max-RSq))

(defmeth morals-model-object-proto :min-RSq-improve
  (&optional (min-RSq-improve nil set))
  (if set (setf (slot-value 'min-RSq-improve) min-RSq-improve))
  (slot-value 'min-RSq-improve))

(defmeth morals-model-object-proto :method
  (&optional (list1 nil set))
  (if set (setf (slot-value 'method) list1))
  (slot-value 'method))

(defmeth morals-model-object-proto :control-panel-method
  (&optional (list1 nil set))
  (if set (setf (slot-value 'control-panel-method) list1))
  (slot-value 'control-panel-method))

(defmeth morals-model-object-proto :vif-list
  (&optional (list1 nil set))
  (if set (setf (slot-value 'vif-list) list1))
  (slot-value 'vif-list))

(defmeth morals-model-object-proto :predictors
  (&optional (object-id nil set))
  (if set (setf (slot-value 'predictors) object-id))
  (slot-value 'predictors))

(defmeth morals-model-object-proto :response
  (&optional (object-id nil set))
  (if set (setf (slot-value 'response) object-id))
  (slot-value 'response))

(defmeth morals-model-object-proto :prev-vis
  (&optional (prev-vis nil set))
  (if set (setf (slot-value 'prev-vis) prev-vis))
  (slot-value 'prev-vis))

(defmeth morals-model-object-proto :container
  (&optional (container nil set))
  (if set (setf (slot-value 'container) container))
  (slot-value 'container))


(defmeth morals-model-object-proto :isnew 
              (response predictors method iterations max-rsq min-rsq-improve 
                        &rest args)
  (send *model-menu* :enabled nil)
  (send self :predictors predictors)
  (send self :response response)
  (send self :data-object current-data)
  (send self :model-abbrev "REG")
  (send self :max-rsq max-rsq)
  (send self :min-rsq-improve min-rsq-improve)
  (cond 
    ((equal method "OLS")
     (setf method "Monotonic")
     (setf iterations 1)
     (send self :method method)
     (send self :control-panel-method 0)
     (send self :iter 1))
    ((equal method "Monotonic")
     (send self :method method)
     (send self :control-panel-method 1)
     (send self :iter iterations))
    ((equal  method "Robust")
     (send self :method method)
     (send self :control-panel-method 2)
     (send self :iter iterations)))
#+containers
  (setf *iter-container* 
        (send self :create-spreadplot-container 0))
  (send self :container 
        (send self :create-spreadplot-container 1))
  (setf *regres-spreadplot-container* (send self :container))
  (apply #'call-next-method args)
  (send *model-menu* :enabled t)
  (send self :fix-help-menu)
  )


(defmeth morals-model-object-proto :fix-help-menu ()
  (let* ((hi (reverse (send *help-menu* :items)))
         (last-item)
         (j 0)
         )
    (dotimes (i (length hi))
             (setf last-item (select hi i))
             (cond 
               ((equal dash-item-proto (first (send last-item :parents)))
                 (send *help-menu* :delete-items last-item))
               (t
                (setf j (1+ j))
                (if (<= j 6)
                    (send *help-menu* :delete-items last-item)
                    (return)))))))

(defmeth morals-model-object-proto :options ()
"Args: none
Constructs and displays the REVISED options dialog window for regression models.
Returns nil or a four element list.  Returns nil when dialog canceled or when no response or predictor variables selected, returns four element list otherwise.  The first element of the list is a list of response variable indices.  The second element is a list of predictor variable indices. The third element is the index of the weight variable, or nil for unweighted analysis.  The fourth element is T for intercept models, nil for non-intercept models."
  (when (not (send self :dialog))
        (send self :iv ($position (send self :predictors) 
                                  (send self :variables)))
        (send self :dv ($position (send self :response) 
                                  (send self :variables))))
  (when (send self :dialog)
  (let* ((mob self)
        ; (box-text-item (send text-item-proto :new "Multiple Regression"))
         (select-toggle (send choice-item-proto :new (list
                              "Response"
                              "Predictors") 
                              :value 0))
         (method-toggle (send choice-item-proto :new (list "Ordinary Regression" 
                              "Monotonic Regression"); "Robust Regression"
                              :value 0))
        ; (robust-method? (send toggle-item-proto :new  "Robust Regression"))
         (var-text-item (send text-item-proto :new "Selectable Variables"))
         (rsp-text-item (send text-item-proto :new "Selected Response"))
         (prd-text-item (send text-item-proto :new "Selected Predictors"))
         (var-list (send self :variables))
         (rsp-list (repeat " " 1))
         (prd-list (repeat " " (length var-list)))
         (rsp-nums nil)
         (prd-nums nil)
         (weight-num nil)
         (var-list-item (send list-item-proto :new var-list
                              :action #'(lambda () (move-vars &optional dc))))
         (rsp-list-item (send list-item-proto :new rsp-list))
         (prd-list-item (send list-item-proto :new prd-list))
         (ok        (send modal-button-proto :new "OK"))
         (cancel    (send modal-button-proto :new "Cancel"))
         (reg-dialog (send modal-dialog-proto :new
                           (list (list (list select-toggle
                                             var-text-item
                                             var-list-item
                                             ok cancel
                                             )
                                       (list (list (list rsp-text-item
                                                         rsp-list-item))
                                             prd-text-item
                                             prd-list-item
                                             )))
                           :default-button ok
                           :title "Multiple Regression"))
         )


    (defmeth ok :do-action ()
      (let ((dialog (send ok :dialog))
            (method (send method-toggle :value))
            )
        (send mob :iv prd-nums)
        (send mob :dv rsp-nums)

;==================================================
;note that the analysis method is never OLS, but that
;we simulate OLS by doing 1 iteration of Monotonic and
;only showing the initial OLS starting values
;by crippling the control panel options.
;there are two slots that allow for simulated OLS
;Method slot is used throughout, so only Monotonic or Robust method
;are computed with iter=1 (2 for Robust), as set below.
;Control-panel-method slot is only used by crontrol 
;panel to determine which options method is really used.
;==================================================

        (cond
          ((and (= 1 (length prd-nums)) (> (send method-toggle :value) 0))
           (error-message "Monotonic and Robust regression can only be used when there is more than 1 predictor."))
          ((or (> 1 (length prd-nums)) (> 1 (length rsp-nums)))
           (error-message "You must select at least one response and one predictor variable."))
          (t 
           (send mob :method (if (> 2 method) "Monotonic" "Robust"))
           (send mob :control-panel-method (send method-toggle :value))
           (send mob :iter (if (= method 2) 2 1))
           (setf method (send mob :method))
           (send dialog :modal-dialog-return t)))
        ))

    (defmeth cancel :do-action ()
      (let ((dialog (send cancel :dialog)))
        (send dialog :modal-dialog-return nil)))

    (defmeth var-list-item :do-action (&optional dbl-clk)
      (let* ((n (send self :selection))
             (s (select (send self :slot-value 'list-data) n))
             (m nil))
        (when (and n (not (equal s " ")))
              (cond 
                ((and (= 0 (length rsp-nums))
                      (= 0 (send select-toggle :value)))
                 (send self :set-text n " ") ;OK
                 (setf m (position " " 
                                   (send rsp-list-item :slot-value  'list-data)
                                   :test 'equal))
                 (send select-toggle :value 1)
                 (send rsp-list-item :set-text m s)
                 (setf rsp-nums (concatenate 'list rsp-nums (list n))))
                ((= 1 (send select-toggle :value))
                 (send self :set-text n " ") ;OK
                 (setf m (position " " 
                                   (send prd-list-item :slot-value  'list-data)
                                   :test 'equal))
                 (send prd-list-item :set-text m s)
                 (setf prd-nums (concatenate 'list prd-nums (list n)))))
              (send self :selection nil))))

    (defmeth rsp-list-item :do-action (&optional dbl-clk)
      (let* ((n (send self :selection))
             (L (length rsp-nums))
             (s nil)
             (m nil))
        (when n
              (setf s (select (send self :slot-value 'list-data) n))
              (cond
                ((= L 0)
                 (send self :selection nil))
                ((> L n) 
                 (setf m (select rsp-nums n))
                 (when (< n (1- L))
                       (dolist (i (iseq n (- L 2)))
                               (send self :set-text i 
                                     (select (send self :slot-value 
                                                   'list-data) (1+ i)))))
                 (send self :set-text (1- L) " ")
                 (send var-list-item :set-text m s)
                 (send self :selection nil)
                 (setf rsp-nums (remove m rsp-nums)))))))

    (defmeth prd-list-item :do-action (&optional dbl-clk)
      (let* ((n (send self :selection))
             (L (length prd-nums))
             (s nil)
             (m nil))
        (when n
              (setf s (select (send self :slot-value 'list-data) n))
              (cond
                ((= L 0)
                 (send self :selection nil))
                ((> L n)
                 (setf m (select prd-nums n))
                 (when (< n (1- L))
                       (dolist (i (iseq n (- L 2)))
                               (send self :set-text i 
                                     (select (send self :slot-value
                                                   'list-data) (1+ i)))))
                 (send self :set-text (1- L) " ")
                 (send var-list-item :set-text m s)
                 (send self :selection nil)
                 (setf prd-nums (remove m prd-nums)))
                (t
                 (send self :selection nil))
                ))))
    (cond 
      ((send reg-dialog :modal-dialog)
       (enable-container (send self :container))
       (list rsp-nums prd-nums))
      (t nil))
    )))


(defmeth morals-model-object-proto :analysis () 
  (let* ((data-mat (send self :data-matrix))
         (nobs (send self :nobs))
         (ivar-mat (select data-mat (iseq nobs) (send self :iv)))
         (dvar (combine (select data-mat (iseq nobs) (send self :dv))))
         (iter (send self :iter))
         (max-RSq (send self :max-RSq))
         (min-RSq-improve (send self :min-RSq-improve))
         (dial nil)
         (object nil)
         (method "OLS")
         (vif-list nil))
    (unless (send self :predictors)
            (send self :predictors (select (send self :variables) (send self :iv))))
    (unless (send self :response)
            (send self :response (first (select (send self :variables) (send self :dv)))))
    (setf object (optimal-regression-model ivar-mat dvar
                  :iterations iter :maximum-RSq max-RSq 
                  :minimum-RSq-improve min-RSq-improve
                  :vista-object self :method method :vif-list vif-list))  
    (send self :morals-model object) 
    (send self :robust-model (robust-regression-model ivar-mat dvar))
    (send self :lin-reg-model 
          (regression-model ivar-mat dvar :display nil :print nil
                :predictor-names (send self :predictors)
                :response-name (send self :response)))
    (send (send self :robust-model) :vista-object self)
;next lines moved here by fwy from :isnew oct 2 96 and rewritten feb 11 97
    (when (or (equalp (send self :method) "Robust")
              (equalp (send self :method) "Monotonic"))
          (send self :create-spreadplot "no")
          (if (equalp (send self :method) "Monotonic")
              (send (send self :spreadplot-supervisor) :iterate2 iter "no")
              (send (send self :spreadplot-supervisor) :iterate3 iter "no"))
          )
    object))

(defmeth morals-model-object-proto :save-model-template (data-object)
"Args: (data-object)
DATA-OBJECT is the object-identification information of a data object. 
The method contains a template for saving the model-object." 
  (let* ((dv (send (send self :morals-model) :y))
         (iv (send (send self :morals-model) :x))
         (data (combine (bind-columns dv iv)))
         (response (select (send self :variables) (send self :dv)))
         (predictors (select (send self :variables) (send self :iv)))
         (variables  (combine response predictors))
         )
  `(regression-analysis    
    :title           ,(strcat (send self :method) 
                              " Univariate " 
                              (send self :title))
    :name            ,(send self :name) 
    :dialog           nil
    :method          ,(send self :method)
    :iterations      ,(send self :iter)
    :max-rsq         ,(send self :max-rsq)
    :min-rsq-improve ,(send self :min-rsq-improve)
    :response        ,response
    :predictors     ',predictors
    :data             (data ,(send data-object :name)
                            :title      ,(send data-object :title)
                            :variables ',variables
                            :labels    ',(send self :labels)
                            :data      ',data))
    ))

(defmeth morals-model-object-proto :create-data 
  (&key (dialog nil))
  (if (not (eq current-object self)) (setcm self))
  (let* ((morals-model (send self :morals-model))
         (residuals (send morals-model :print-residuals))
         (leverages (send morals-model :print-leverages))
         (dffits (send self :dffits))
         (nobs (send self :nobs))
         (weights (send (send self :robust-model) :weights))
         (data-mat nil)
         )
    (setf data-mat (bind-columns residuals dffits leverages))
    (when weights (setf data-mat (bind-columns data-mat weights)))
    (setf vars '("Response" "Fit Values" "Residuals" 
                            "Studt.Resid" "Ext.Studt.Resid" "DFFITS" "Leverages" 
                            "CooksDist" ))
    (if weights (setf vars (combine vars "Weights")))
    (when (equal (send self :control-panel-method) 1)
          (setf data-mat (bind-columns 
                          (send morals-model :yraw) data-mat))
          (setf (select vars 0) "Monotone")
          (setf vars (combine "Response" vars)))
    (data (concatenate 'string "Output-" (send self :name))
          :created (send *workmap* :selected-icon)
          :creator-object self
          :title (concatenate 'string "Regression Output for " 
                              (send self :title))
          :data (combine data-mat)
          :variables vars
          :labels (send self :labels))
    ))


(defmeth morals-model-object-proto :report (&key (dialog nil))
  (send (send self :morals-model) :morals-display :dialog dialog)
  )

(defmeth morals-model-object-proto :visualize ()
  (cond 
    ((send self :prev-vis)
     (vista-message "You cannot re-visualize the regression model. You must compute a new model by using the Analysis menu, and then visualize it."))
    (t
     (send self :prev-vis t)
     (send self :create-spreadplot))))

(defmeth morals-model-object-proto :vif ()
  (let* ((iv (select (send self :variables) (send self :iv)))
         (i 0)
        ; (mod (send self :morals-model))
         (mod (case (send self :control-panel-method)
                (0 (send self :lin-reg-model))
                (1 (send self :morals-model))
                (2 (send self :robust-model))))
         (nobs (send self :nobs))
         (vif nil)
         (vif-list nil)
         )
  (dotimes (i (length (send self :iv)))
           (let* ((vif nil)) 
             (setf vif (/ 1 (- 1 
                (send (regression-model (select (send mod :x)
                (iseq nobs) (remove i (iseq (length (send self :iv)))))
                            (combine (select (send mod :x) (iseq nobs)
                            (select (iseq (length (send self :iv))) i)))
                                        :print nil)
                      :r-squared))))
             (if (= i 0) (setf vif-list vif) (setf vif-list (combine vif-list vif)))
             ))
(send self :vif-list vif-list)))

(defmeth morals-model-object-proto :dffits ()
  (let* ((dffits nil)
         (model (case (send self :control-panel-method)
                  (0 (send self :lin-reg-model))
                  (1 (send self :morals-model))
                  (2 (send self :robust-model))))
         )
    ;(if (equalp (send self :method) "Robust") 
    ;    (setf model (send self :robust-model)) 
    ;    (setf model (send self :morals-model)))
    (setf dffits (* (sqrt (/ (send model :leverages)
                             (- 1 (send model :leverages))))
                    (send model :externally-studentized-residuals)))
    dffits))


(defmeth morals-model-object-proto :autocorr () 
  (let* ((autocorr nil)
         (model nil))
    (if (equalp (send self :method) "Robust") (setf model (send self :robust-model)) (setf model (send self :morals-model)))
    (setf autocorr 
          (correlation (select (send model :raw-residuals) 
                         (iseq (1- (send self :nobs))))
                       (select (send model :raw-residuals)
                         (+ 1 (iseq (1- (send self :nobs)))))))
    autocorr))


(defmeth morals-model-object-proto :spreadplot-supervisor (&optional (val nil set)) 
  (when set (setf (slot-value 'spreadplot-supervisor) val)) 
  (slot-value 'spreadplot-supervisor))


(defmeth morals-model-object-proto :show-spreadplot-supervisor ()
"Method args: ()
Shows the spreadplot-supervisor in the spreadplot slot (if any)" 
  (when (send self :spreadplot-supervisor)
        (send (send self :spreadplot-supervisor) :show-ssp) )) 

#|The next 3 methods are apparently not needed

(defmeth morals-model-object-proto :install-spreadplot-supervisor (spreadplot-supervisor)
"Method args: SPREADPLOT
Installs the spreadplot-object SPREADPLOT into the current morals model object, unless a spreadplot object is already installed.  Returns the object-id of the installed spreadplot-supervisor-object.  " 
      (if (send spreadplot-supervisor :menu) 
         (send (send spreadplot-supervisor :menu) :install))
      spreadplot-supervisor)

(defmeth morals-model-object-proto :delete-spreadplot-supervisor ()
"Method args: ()
Deletes the spreadplot-supervisor in the spreadplot slot (if any). " 
  (when (send self :spreadplot-supervisor)
        (send (send self :spreadplot-supervisor) :remove)
        (setf (slot-value 'spreadplot-supervisor) 'nil)  ))

(defmeth morals-model-object-proto :hide-spreadplot-supervisor ()
"Method args: ()
Hides the spreadplot-supervisor in the spreadplot slot (if any). " 
  (when (send self :spreadplot-supervisor)
        (send (send self :spreadplot-supervisor) :hide-ssp) ))

|#


#|

;(setf *load-verbose* t)
(load (strcat *vista-dir-name* "rg0robst.lsp"))
(load (strcat *vista-dir-name* "rg1simpl.lsp"))
(load (strcat *vista-dir-name* "rg1supr1.lsp"))
(load (strcat *vista-dir-name* "rg2supr2.lsp"))
(load (strcat *vista-dir-name* "rg3iters.lsp"))
(load (strcat *vista-dir-name* "rg4splot.lsp"))
(load (strcat *vista-dir-name* "rg5plots.lsp"))
(load (strcat *vista-dir-name* "rg6plots.lsp"))
(load (strcat *vista-dir-name* "rg7lsmtr.lsp"))
(load (strcat *vista-dir-name* "rg8cntrl.lsp"))
(load (strcat *vista-dir-name* "rg9help.lsp"))
(load (strcat *vista-dir-name* "regdemo.lsp"))
;(setf *load-verbose* nil)

|#